home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / you-075a.lha / you-075a / modules.c < prev    next >
C/C++ Source or Header  |  1992-07-22  |  39KB  |  1,719 lines
  1. /* ******************************************************************** */
  2. /*  modules.c        copyright (c) codemist and university of bath 1989 */
  3. /*                                                                      */
  4. /* creation of modules                            */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: modules.c,v 1.27 1992/07/22 15:34:25 pab Exp $
  9.  *
  10.  * $Log: modules.c,v $
  11.  * Revision 1.27  1992/07/22  15:34:25  pab
  12.  * macro expansion evils...
  13.  *
  14.  * Revision 1.26  1992/05/28  11:26:40  pab
  15.  * not a lot
  16.  *
  17.  * Revision 1.25  1992/05/19  11:25:07  pab
  18.  * bindings exported with write permission, errors msgs improved
  19.  *
  20.  * Revision 1.24  1992/04/27  21:58:15  pab
  21.  * added more BCI dependency, plus corrected listify(c_fn)
  22.  *
  23.  * Revision 1.23  1992/04/26  20:55:02  pab
  24.  * fixes for interpreter
  25.  *
  26.  * Revision 1.22  1992/03/14  16:39:20  pab
  27.  * arg checking (again)
  28.  *
  29.  * Revision 1.21  1992/03/14  14:33:48  pab
  30.  * bytecode optional
  31.  *
  32.  * Revision 1.20  1992/03/07  21:45:16  pab
  33.  * apply changes
  34.  *
  35.  * Revision 1.19  1992/02/27  15:48:17  pab
  36.  * bytecode additions
  37.  *
  38.  * Revision 1.18  1992/02/10  12:06:20  pab
  39.  * new apply functions
  40.  *
  41.  * Revision 1.17  1992/02/02  16:33:47  pab
  42.  * improved backtrace output
  43.  *
  44.  * revision 1.12  1991/04/02  21:25:30  kjp
  45.  * compiler tidying.
  46.  *
  47.  * revision 1.11  1991/03/27  17:37:32  kjp
  48.  * fixed some definition ordering problems.
  49.  *
  50.  * revision 1.10  1991/03/14  14:14:14  fdla
  51.  * *** empty log message ***
  52.  *
  53.  * revision 1.9  1991/03/14  11:43:54  fdla
  54.  * c and elvira function switches expanded (20 args)
  55.  *
  56.  * revision 1.8  1991/03/13  16:57:34  kjp
  57.  * no change.
  58.  *
  59.  * revision 1.7  1991/02/19  18:53:04  kjp
  60.  * (expose spec*) in module body for reexportation.
  61.  *
  62.  * revision 1.6  1991/02/19  17:07:17  kjp
  63.  * updated for new module syntax with full streaming.
  64.  *
  65.  * revision 1.5  1991/02/13  18:24:17  kjp
  66.  * pass.
  67.  *
  68.  */
  69.  
  70. /*
  71.  * change log:
  72.  *   version 1, may 1989
  73.  *    major rewrite after talking to jap
  74.  *    added include function
  75.  *
  76.  *      threw it all away and did it again 'right' ! kjp (15/3/90)    
  77.  *    Did the same... pab (11/91)
  78.  */
  79. #define call_generic foo
  80.  
  81. #include "defs.h"
  82. #include "structs.h"
  83. #include "funcalls.h"
  84.  
  85. #include "error.h"
  86. #include "global.h"
  87.  
  88.  
  89. #include "allocate.h"
  90. #include "lists.h"
  91. #include "table.h"
  92. #include "modules.h"
  93. #include "toplevel.h"
  94. #include "symboot.h"
  95. #include "specials.h"
  96. #include "root.h"
  97. #include "class.h"
  98. #include "ngenerics.h"
  99. #include "calls.h"
  100. #include "bvf.h"
  101.  
  102. #undef call_generic
  103. /* elsewheres... */
  104. EUDECL(call_generic);
  105. /* in modules.h */
  106. EUDECL(Fn_module_value);
  107. static EUDECL(module_set_new_aux);
  108. EUDECL(register_module_import);
  109.  
  110. static LispObject sym_include_forms;
  111.  
  112. SYSTEM_GLOBAL(LispObject,current_interactive_module);
  113.  
  114. /* global module table --- needed for modops, etc*/
  115.  
  116. LispObject global_module_table;
  117.  
  118. /* hooking / unhooking */
  119.  
  120. LispObject put_module(LispObject *stacktop, LispObject name,LispObject module)
  121. {
  122.   if (global_module_table == NULL) {
  123.     fprintf(stderr,"initerror: NULL module table");
  124.     exit(1);
  125.   }
  126.   STACK_TMP(name);
  127.   EUCALL_3(tref_updator, global_module_table,name,module);
  128.   UNSTACK_TMP(name);
  129.   return(name);
  130. }
  131.  
  132. LispObject get_module(LispObject *stacktop, LispObject name)
  133. {
  134.   ARG_1(stacktop) = name;
  135.   ARG_0(stacktop) = global_module_table;
  136.   return(Fn_tref(stacktop));
  137. }
  138.  
  139. int module_loaded_p(LispObject* stacktop, LispObject name)
  140. {
  141.   return((get_module(stacktop, name) != nil));
  142. }
  143.  
  144. /* utilities !! */
  145.  
  146.  
  147. LispObject module_exports(LispObject mod)
  148. {
  149.   if (is_c_module(mod)) return(mod->C_MODULE.exported_names);
  150.   if (is_i_module(mod)) return(mod->I_MODULE.exported_names);
  151.  
  152.   CallError(NULL, "module exports: unknown module type",mod,NONCONTINUABLE);
  153.  
  154.   return(nil);
  155. }
  156.  
  157. void process_expose_form(LispObject *stacktop,LispObject mod,LispObject forms)
  158. {
  159.   static LispObject export_filter(LispObject *,LispObject,LispObject);
  160.   LispObject union_filter(LispObject *,LispObject,LispObject);
  161.   LispObject xx;
  162.  
  163.   STACK_TMP(mod);
  164.   xx=union_filter(stacktop,forms,mod);
  165.   UNSTACK_TMP(mod);
  166.   (void) export_filter(stacktop,xx,mod);
  167. }    
  168.       
  169. EUFUN_2( process_exports, mod, names)
  170. {
  171.  
  172.   if (is_c_module(mod))
  173.     CallError(stacktop,
  174.           "process exports: can't modify compiled module exports",
  175.           mod,NONCONTINUABLE);
  176.  
  177.   if (is_i_module(mod)) {
  178.     LispObject walker = names;
  179.  
  180.     if (names == nil) return nil;
  181.  
  182.     mod->I_MODULE.bounce_flag = TRUE;
  183.  
  184.     while (is_cons(walker)) {
  185.  
  186.       if (!is_symbol(CAR(walker))) {
  187.     STACK_TMP(walker);
  188.     EUCALL_2(process_top_level_form,ARG_1(stackbase)/*mod*/,CAR(walker)); 
  189.     UNSTACK_TMP(walker);
  190.       }
  191.       walker = CDR(walker);
  192.     }
  193.  
  194.     mod = ARG_0(stackbase);
  195.     mod->I_MODULE.bounce_flag = FALSE;
  196.  
  197.     /* all valid exports */
  198.  
  199.     walker = ARG_1(stackbase);
  200.  
  201.     while(is_cons(walker)) {
  202.       if (is_symbol(CAR(walker))) {
  203.     LispObject xx;
  204.     STACK_TMP(walker);
  205.     EUCALLSET_2(xx, Fn_memq,CAR(walker),mod->I_MODULE.exported_names);
  206.     UNSTACK_TMP(walker);
  207.     if (xx == nil) {
  208.       LispObject xx;
  209.       mod = ARG_0(stackbase);
  210.       STACK_TMP(walker);
  211.       EUCALLSET_2(xx, Fn_cons, CAR(walker),mod->I_MODULE.exported_names);
  212.       mod = ARG_0(stackbase);
  213.       mod->I_MODULE.exported_names = xx;
  214.       UNSTACK_TMP(walker);
  215.     }
  216.       }
  217.  
  218.       walker = CDR(walker);
  219.     }
  220.  
  221.     return nil;
  222.   }
  223.  
  224.   CallError(stacktop, "process exports: non-module arg",mod,NONCONTINUABLE);
  225. }
  226. EUFUN_CLOSE
  227.  
  228. EUFUN_2( process_included_forms, mod, forms)
  229. {
  230.   extern LispObject Fn_close(LispObject*);
  231.  
  232.   LispObject path,stream,read;
  233.   FILE *cstream;
  234.  
  235.   if (!is_cons(forms))
  236.     CallError(stacktop, "inlude-forms: missing path",forms,NONCONTINUABLE);
  237.  
  238.   if (!is_string((path = CAR(forms))))
  239.     CallError(stacktop, "include-forms: bad path",path,NONCONTINUABLE);
  240.  
  241.   cstream = fopen(stringof(path),"r");
  242.   if (cstream == NULL)
  243.     CallError(stacktop, "include-forms: can't open file",path,NONCONTINUABLE);
  244.  
  245.   stream = (LispObject) allocate_stream(stacktop, cstream,'r');
  246.  
  247.   fprintf(StdOut->STREAM.handle,"including \'%s\'\n",stringof(path));
  248.  
  249.   while (1) {
  250.     STACK_TMP(stream);
  251.     EUCALLSET_1(read, Fn_read, stream);
  252.     UNSTACK_TMP(stream);
  253.     if (read == q_eof) break;
  254.     STACK_TMP(stream);
  255.     EUCALLSET_2(read,process_top_level_form,ARG_0(stackbase),read);
  256.     UNSTACK_TMP(stream);
  257.   }
  258.  
  259.   EUCALL_1(Fn_close, stream);
  260.  
  261.   fprintf(StdOut->STREAM.handle,"included \'%s\'\n",stringof(path));
  262.  
  263. }
  264. EUFUN_CLOSE
  265.  
  266. static LispObject sym_only;
  267. static LispObject sym_except;
  268.  
  269. static LispObject module_addresses(LispObject *stacktop, LispObject mod)
  270. {
  271.   LispObject exports,addresses;
  272.  
  273.   addresses = nil;
  274.   exports = mod->I_MODULE.exported_names;
  275.  
  276.   
  277.   while (is_cons(exports)) {
  278.     LispObject name, xx;
  279.     STACK_TMP(CDR(exports));
  280.     STACK_TMP(mod);
  281.     STACK_TMP(addresses);
  282.  
  283.     name = CAR(exports);
  284.     
  285.     EUCALLSET_2(xx, Fn_cons, name, mod); /* canonical address */
  286.     EUCALLSET_2(name,Fn_cons, CAR(xx)/*name*/, xx);
  287.     UNSTACK_TMP(addresses);
  288.     EUCALLSET_2(addresses, Fn_cons,name, addresses);
  289.     UNSTACK_TMP(mod);
  290.     UNSTACK_TMP(exports);
  291.   }
  292.  
  293.  
  294.   return(addresses);
  295. }
  296.  
  297. /* filters */
  298.  
  299. static LispObject only_filter(LispObject *stacktop,
  300.                   LispObject names,LispObject addresses)
  301. {
  302.   LispObject remains;
  303.  
  304.   remains = nil;
  305.  
  306.   while (is_cons(addresses)) {
  307.  
  308.     STACK_TMP(addresses);
  309.     STACK_TMP(remains);
  310.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) != nil) {
  311.       UNSTACK_TMP(remains);
  312.       STACK_TMP(names);
  313.       EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  314.       UNSTACK_TMP(names);
  315.     }
  316.     else UNSTACK_TMP(remains);
  317.  
  318.     UNSTACK_TMP(addresses);
  319.     addresses = CDR(addresses);
  320.  
  321.   }
  322.  
  323.   return(remains);
  324. }
  325.  
  326. static LispObject except_filter(LispObject *stacktop,
  327.                 LispObject names,LispObject addresses)
  328. {
  329.   LispObject remains;
  330.  
  331.   remains = nil;
  332.  
  333.   while (is_cons(addresses)) {
  334.  
  335.     STACK_TMP(addresses);
  336.  
  337.     if (EUCALL_2(Fn_memq,CAR(CAR(addresses)),names) == nil) 
  338.       {
  339.     STACK_TMP(names);
  340.     EUCALLSET_2(remains, Fn_cons, CAR(addresses),remains);
  341.     UNSTACK_TMP(names);
  342.       }
  343.  
  344.     UNSTACK_TMP(addresses);
  345.  
  346.     addresses = CDR(addresses);
  347.  
  348.   }
  349.  
  350.   return(remains);
  351. }
  352.  
  353. static LispObject name_list_pair(LispObject *stacktop,
  354.                  LispObject k,LispObject l)
  355. {
  356.   while (is_cons(l)) {
  357.  
  358.     if (!is_cons(CAR(l)))
  359.       CallError(stacktop,
  360.         "module importation: bad rename names",l,NONCONTINUABLE);
  361.  
  362.     if (k == CAR(CAR(l))) 
  363.       return(CAR(l));
  364.     else
  365.       l = CDR(l);
  366.   }
  367.  
  368.   return(nil);
  369. }
  370.  
  371. static LispObject rename_filter(LispObject *stacktop,
  372.                 LispObject pairs,LispObject addresses)
  373. {
  374.   LispObject walker;
  375.  
  376.   walker = addresses;
  377.  
  378.   while (is_cons(walker)) {
  379.     LispObject pair;
  380.     STACK_TMP(walker);
  381.     pair = name_list_pair(stacktop,CAR(CAR(walker)),pairs);
  382.     UNSTACK_TMP(walker);
  383.     if (pair != nil) { /* to be renamed... */
  384.  
  385.       CAR(CAR(walker)) = CAR(CDR(pair));
  386.  
  387.     }
  388.  
  389.     walker = CDR(walker);
  390.   }
  391.   
  392.   return(addresses);
  393. }
  394.  
  395. LispObject
  396.   union_filter(LispObject *stacktop, LispObject list,LispObject context)
  397. {
  398.   static LispObject filter_import_thang(LispObject*,LispObject,LispObject);
  399.   LispObject all;
  400.  
  401.   all = nil;
  402.  
  403.   while (is_cons(list)) {
  404.     LispObject xx;
  405.  
  406.     STACK_TMP(CDR(list));
  407.     STACK_TMP(context);
  408.     STACK_TMP(all);
  409.     xx = filter_import_thang(stacktop,CAR(list),context);
  410.     UNSTACK_TMP(all);
  411.     EUCALLSET_2(all, Fn_nconc, xx,all);
  412.     UNSTACK_TMP(context);
  413.  
  414.     UNSTACK_TMP(list);
  415.  
  416.   }
  417.  
  418.   return(all);
  419. }
  420.  
  421. static LispObject export_filter(LispObject *stacktop,
  422.                 LispObject ads,LispObject mod)
  423. {
  424.   LispObject walker;
  425.   
  426.   STACK_TMP(ads);
  427.   walker = ads;
  428.  
  429.   while (is_cons(walker)) {
  430.     LispObject name;
  431.  
  432.     name = CAR(CAR(walker)); 
  433.  
  434.     STACK_TMP(CDR(walker));
  435.  
  436.     STACK_TMP(mod);
  437.     STACK_TMP(name);
  438.     if (EUCALL_2(Fn_memq,name,mod->I_MODULE.exported_names) == nil)
  439.       {
  440.     LispObject xx;
  441.     UNSTACK_TMP(name);
  442.     EUCALLSET_2(xx, Fn_cons,name,mod->I_MODULE.exported_names);
  443.     UNSTACK_TMP(mod);
  444.     mod->I_MODULE.exported_names = xx;
  445.       }
  446.     else 
  447.       { UNSTACK_TMP(name);    
  448.     UNSTACK_TMP(mod);
  449.       }
  450.     UNSTACK_TMP(walker);
  451.  
  452.   }
  453.  
  454.   UNSTACK_TMP(ads);
  455.   return(ads);
  456. }
  457.  
  458. static void register_filtered_addresses(LispObject *stacktop,
  459.                     LispObject ads,LispObject mod)
  460. {
  461.   while (is_cons(ads)) {
  462.     LispObject first;
  463.     
  464.     first = CAR(ads); ads = CDR(ads);
  465.     STACK_TMP(mod);
  466.     STACK_TMP(ads);
  467.     EUCALL_4(register_module_import,mod,
  468.          CAR(first),CDR(CDR(first)),
  469.          CAR(CDR(first)));
  470.     UNSTACK_TMP(ads);
  471.     UNSTACK_TMP(mod);
  472.   }
  473. }
  474.     
  475. static LispObject filter_import_thang(
  476.               LispObject* stacktop, LispObject spec,LispObject context)
  477. {
  478.   LispObject op,xx;
  479.  
  480.   if (is_symbol(spec)) {
  481.     STACK_TMP(spec);
  482.     EUCALL_1(load_module,spec);
  483.     UNSTACK_TMP(spec);
  484.     xx= get_module(stacktop,spec);
  485.     return(module_addresses(stacktop,xx));
  486.   }
  487.  
  488.   if (!is_cons(spec)) 
  489.     CallError(stacktop, "module importation: invalid import spec",spec,NONCONTINUABLE);
  490.  
  491.   op = CAR(spec); spec = CDR(spec);
  492.  
  493.   if (op == sym_only) {
  494.     
  495.     if (!is_cons(spec))
  496.       CallError(stacktop, "module importation: bad only form",spec,NONCONTINUABLE);
  497.     
  498.     STACK_TMP(CAR(spec));
  499.     xx=union_filter(stacktop, CDR(spec),context);
  500.     UNSTACK_TMP(spec);
  501.     return(only_filter(stacktop,spec,xx));
  502.  
  503.   }
  504.  
  505.   if (op == sym_except) {
  506.  
  507.     if (!is_cons(spec))
  508.       CallError(stacktop, "module importation: bad except form",spec,NONCONTINUABLE);
  509.     STACK_TMP(CAR(spec));
  510.     xx=union_filter(stacktop, CDR(spec),context);
  511.     UNSTACK_TMP(spec);
  512.     return(except_filter(stacktop,spec,xx));
  513.  
  514.   }
  515.  
  516.   if (op == sym_rename) {
  517.  
  518.     if (!is_cons(spec))
  519.       CallError(stacktop, "module importation: bad rename form",spec,NONCONTINUABLE);
  520.     STACK_TMP(CAR(spec));
  521.     xx= union_filter(stacktop, CDR(spec),context);
  522.     UNSTACK_TMP(spec);
  523.     return(rename_filter(stacktop,spec,xx));
  524.  
  525.   }
  526.  
  527.   if (op == sym_export) {
  528.     STACK_TMP(spec); STACK_TMP(context);
  529.     xx=union_filter(stacktop, spec,context);
  530.     UNSTACK_TMP(context); UNSTACK_TMP(spec);
  531.     return(export_filter(stacktop,xx,context));
  532.  
  533.   }
  534.  
  535.   CallError(stacktop, "module importation: invalid import operation",op,NONCONTINUABLE);
  536.  
  537.   return(nil);
  538. }
  539.  
  540. void process_import_form(LispObject *stackbase,LispObject mod,LispObject spec)
  541. {
  542.   LispObject *stacktop=stackbase+1;
  543.   
  544.   ARG_0(stackbase)=mod;
  545.  
  546.   if (!is_cons(spec))
  547.     CallError(stacktop,
  548.           "import: invalid NULL import spec",spec,NONCONTINUABLE);
  549.  
  550.   while (is_cons(spec)) {
  551.     LispObject name = CAR(spec);
  552.     STACK_TMP(CDR(spec));
  553.  
  554.     if (is_symbol(name)) {
  555.       LispObject inmod,exports;
  556.       
  557.       STACK_TMP(name);
  558.       EUCALL_1(load_module,name);
  559.       UNSTACK_TMP(name);
  560.  
  561.       inmod = get_module(stacktop,name);
  562.       mod=ARG_0(stackbase);
  563.       exports = module_exports(inmod);
  564.  
  565.       while (exports != nil) {
  566.     STACK_TMP(mod);
  567.     STACK_TMP(inmod);
  568.     STACK_TMP(CDR(exports));
  569.     EUCALL_4(register_module_import,ARG_0(stackbase)/*mod*/,
  570.          CAR(exports),inmod,CAR(exports));
  571.     UNSTACK_TMP(exports);
  572.     UNSTACK_TMP(inmod);
  573.     UNSTACK_TMP(mod);
  574.       }
  575.  
  576.     }
  577.     else {
  578.       
  579.       CallError(stacktop,
  580.         "import: non-symbolic module name",spec,NONCONTINUABLE);
  581.  
  582.     }
  583.  
  584.     UNSTACK_TMP(spec);
  585.  
  586.   }
  587.  
  588. }
  589.  
  590. void process_import_spec(LispObject *stacktop, LispObject mod,LispObject spec)
  591. {
  592.   LispObject xx;
  593.   STACK_TMP(mod);
  594.   xx=union_filter(stacktop, spec,mod);
  595.   UNSTACK_TMP(mod);
  596.   register_filtered_addresses(stacktop,xx,mod);
  597. }
  598.  
  599.  
  600. EUFUN_2(process_top_level_form, mod, form)
  601. {
  602.   LispObject op;
  603.  
  604.   /* ok, so here's the game plan -
  605.    
  606.    * for each form, check out the car.
  607.    * if it's not a symbol - crash, probably, for the moment...
  608.    * a symbol means check out any imported macros...
  609.    *   no macros means check out special form key words...
  610.    *     none of them means error.
  611.    * expand macros once and try again.
  612.    * for matching keywords, do the bizness
  613.  
  614.    */
  615.  
  616.  top:
  617.   /* interactive hack */
  618.  
  619.   if (!is_cons(form)) RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  620.  
  621.   op = CAR(form); 
  622.  
  623.   if (is_symbol(op)) {
  624.  
  625.     /* really just check for defining forms and 'progn' */
  626.  
  627.     if (op == sym_progn) {
  628.       LispObject walker,ans = nil;
  629.       walker = form;
  630.  
  631.       walker = CDR(walker);
  632.       while (is_cons(walker)) {
  633.     STACK_TMP(CDR(walker));
  634.     mod = ARG_0(stackbase);
  635.     EUCALLSET_2(ans, process_top_level_form,mod,CAR(walker));
  636.     UNSTACK_TMP(walker);
  637.       }
  638.  
  639.       return(ans);
  640.     }
  641.  
  642.     /*
  643.     if (op == sym_define) {
  644.       return(TL_define(stacktop,mod,CDR(form)));
  645.     }
  646.     */
  647.     if (op == sym_defun)       {
  648.       return(TL_defun(stacktop,mod,CDR(form)));
  649.     }
  650.     if (op == sym_deflocal) {
  651.       return(TL_deflex(stacktop,mod,CDR(form)));
  652.     }
  653.     if (op == sym_defmacro) {
  654.       return(TL_defmacro(stacktop,mod,CDR(form)));
  655.     }
  656.  
  657.     if (op == sym_defvar) return(TL_defvar(stacktop,mod,CDR(form)));
  658.       
  659.     if (op == sym_defconstant) return(TL_defconstant(stacktop,mod,CDR(form))); 
  660.  
  661.     if (op == sym_import) {
  662.       process_import_form(stacktop,mod,CDR(form));
  663.       return(nil);
  664.     }
  665.  
  666.     if (op == sym_expose) {
  667.       process_expose_form(stacktop,mod,CDR(form)); 
  668.       return(nil);
  669.     }
  670.  
  671.     if (op == sym_export) {
  672.       EUCALL_2(process_exports,mod,CDR(form));
  673.       return(nil);
  674.     }
  675.  
  676.     if (op == sym_include_forms) {
  677.       EUCALL_2(process_included_forms,mod,CDR(form));
  678.       return(nil);
  679.     }
  680.  
  681.     /* hell, that'll do for now */
  682.  
  683.     /* try a macroexpand... */
  684.  
  685.     EUCALLSET_2(form,macroexpand_1,mod,form);
  686.     
  687.     if (CAR(CDR(form)) != nil) {
  688.       while (CAR(CDR(form))!=nil)
  689.     { form = CAR(form);
  690.       mod=ARG_0(stackbase);
  691.       EUCALLSET_2(form, macroexpand_1,mod,form);
  692.     }
  693.       
  694.       form = CAR(form);
  695.       
  696.       mod=ARG_0(stackbase);
  697.       goto top;
  698.     }
  699.  
  700.     form = CAR(form);
  701.  
  702.     /* not a macro... */
  703.  
  704.     /* ok, so for user-friendliness (ho-ho) just to a module eval */
  705.  
  706.     mod=ARG_0(stackbase);
  707.     RETURN_EUCALL(EUCALL_3(module_eval,mod,NULL,form));
  708.   }
  709.  
  710.   /* wasne a symbol - rather than crash, try eval first */
  711.  
  712.   {
  713.     LispObject ans;
  714.  
  715.     EUCALLSET_3(ans,module_eval,mod,NULL,form);
  716.     return(ans);
  717.   }
  718. }
  719. EUFUN_CLOSE
  720.  
  721. /* biggie!! */
  722.  
  723. LispObject backtrace_handle;
  724. LispObject list_backtrace;
  725.  
  726. #define PUSH_TRACE(fun,args) \
  727.   { \
  728.     STACK_TMP(args); STACK_TMP(fun); STACK_TMP(backtrace_handle); \
  729.   }
  730.  
  731. #define SET_TRACE(sp,op,env)    \
  732. {                \
  733.    *(sp)=env;            \
  734.    *((sp)+1)=op;            \
  735.    *((sp)+2)=backtrace_handle;    \
  736. }
  737.  
  738. void quickie_module_eval_backtrace(LispObject *stacktop)
  739. {
  740.   LispObject *walker;
  741.  
  742.   fprintf(StdOut->STREAM.handle,"\n");
  743.  
  744.   for (walker = GC_STACK_BASE(); walker != GC_STACK_POINTER(); ++walker) {
  745.     
  746.     if ((*(walker)) == backtrace_handle) {
  747.       
  748.       fprintf(StdOut->STREAM.handle,"entered: ");
  749.       EUCALL_2(Fn_print, ((*(walker-1)))->FUNCTION.name,StdOut);
  750.  
  751.     }
  752.  
  753.   }
  754.  
  755.   fprintf(StdOut->STREAM.handle,"\n");
  756.  
  757. }
  758.  
  759. void module_eval_backtrace(LispObject *stacktop)
  760. {
  761.   LispObject *walker;
  762.   Env env;
  763.  
  764.   for (walker = GC_STACK_BASE(); walker != stacktop; ++walker) {
  765.     
  766.     if (*walker == backtrace_handle) {
  767.       
  768.       fprintf(StdOut->STREAM.handle,"\n");
  769.       fprintf(StdOut->STREAM.handle,"entered: ");
  770.       EUCALL_2(Fn_print,((*(walker-1)))->FUNCTION.name,StdOut);
  771.       fprintf(StdOut->STREAM.handle,"\n");
  772.  
  773.       if ((*(walker-2)) != NULL && typeof((*(walker-2))) == TYPE_ENV) {
  774.  
  775.     for (env = (Env) (*(walker-2)); env != NULL; env = env->next) {
  776.  
  777.       fprintf(StdOut->STREAM.handle,"  ");
  778.       STACK_TMPV(env);
  779.       EUCALL_2(Fn_prin,env->variable,StdOut);
  780.       UNSTACK_TMPV(env);
  781.       STACK_TMPV(env);
  782.       fprintf(StdOut->STREAM.handle,": ");
  783.       EUCALL_2(Gf_generic_prin,env->value,StdOut);
  784.       fprintf(StdOut->STREAM.handle,"\n");
  785.       UNSTACK_TMPV(env);
  786.     }
  787.  
  788.       }
  789.  
  790.     }
  791.  
  792.   }
  793.  
  794.   fprintf(StdOut->STREAM.handle,"\n");
  795.  
  796. }
  797.  
  798. /*
  799.   *
  800.   * The interpreter lies below 
  801.   */
  802.  
  803. #define check_if(stmt) /* :-> */
  804.  
  805. LispObject module_eval(LispObject *stackbase)
  806. {
  807.   LispObject op;
  808.   LispObject mod,env,form;
  809.   LispObject *stacktop;
  810.  
  811.   mod = ARG_0(stackbase);
  812.   env = ARG_1(stackbase);
  813.   form = ARG_2(stackbase);
  814.   (void) system_stacks_ok_p(stackbase,form); 
  815.   
  816.  
  817.   stackbase+=3;    /* Room for trace */
  818.   ARG_0(stackbase)=mod;
  819.   ARG_1(stackbase)=env;
  820.   ARG_2(stackbase)=form;
  821.  toplabel:  
  822.   mod = ARG_0(stackbase);
  823.   env = ARG_1(stackbase);
  824.   form = ARG_2(stackbase);
  825.  
  826.   stacktop=stackbase+3;
  827.  
  828.   if (!is_cons(form))
  829.     { /* should check for loose special forms */
  830.       if (is_symbol(form))
  831.     {
  832.       LispObject tmp=symbol_ref(stacktop,mod,env,form);
  833.       if (!is_special(tmp)) return(tmp);
  834.       else    
  835.         CallError(stacktop,"Invalid use of reservered word",form,NONCONTINUABLE);
  836.     }
  837.       else    
  838.     return form;
  839.     }
  840.  
  841.   op = CAR(form);
  842.  
  843.   ARG_3(stackbase)=op;
  844.   stacktop++;
  845.  
  846.   if (is_symbol(op))
  847.     { 
  848. #ifndef NODEBUG
  849.       { extern int gc_paranoia;
  850.     if (gc_paranoia)
  851.       fprintf(stderr,"%s\n",stringof(op->SYMBOL.pname));
  852.       }
  853. #endif
  854.       op = symbol_ref(stacktop,mod,(LispObject)env,op);
  855.       ARG_3(stackbase)=op;
  856.     }
  857.   else
  858.     if (is_cons(op))
  859.       {    
  860.     op=EUCALL_3(module_eval,mod,env,op);
  861.     ARG_3(stackbase)=op;
  862.     mod=ARG_0(stackbase);
  863.     env=ARG_1(stackbase);
  864.     form=ARG_2(stackbase);
  865.       }
  866.  
  867.   if (is_macro(op))
  868.     { 
  869.       LispObject newform;
  870.       
  871.       newform = EUCALL_2(module_mv_apply_1,op,CDR(form));
  872.       
  873.       if (!is_cons(newform))
  874.     EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,newform)
  875.       else
  876.     {
  877.       CAR(form) = CAR(newform);
  878.       CDR(form) = CDR(newform);
  879.       EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,form);
  880.     }
  881.     }
  882.  
  883.  
  884.   if (is_c_function(op) || is_c_macro(op) 
  885. #ifdef BCI
  886.       || is_b_function(op) || is_b_macro(op)
  887. #endif
  888.       )
  889.     {
  890.       LispObject lastarg;
  891.  
  892.       LispObject walker, extras = nil;
  893.       int i, args, extra;
  894.       BEGIN_NARY_EUCALL();
  895.  
  896.       walker = CDR(form);
  897. #ifdef BCI
  898.       args = ((is_c_function(op)||is_c_macro(op))
  899.           ? op->C_FUNCTION.argtype
  900.           : intval(bytefunction_nargs(op)));
  901. #else
  902.       args = op->C_FUNCTION.argtype;
  903. #endif
  904.       extra = (args < 0);
  905.       args = extra ? -args : args;
  906.       
  907.       if (is_c_function(op) || is_c_macro(op))
  908.     if (op->C_FUNCTION.env != NULL)
  909.       { STACK_TMP(nil); /* space for arg */
  910.         NARY_PUSH_ARG((LispObject)op->C_FUNCTION.env);
  911.       }
  912.  
  913.       if (args==0)
  914.     {
  915.       if (walker!=nil)
  916.         CallError(stacktop,"Too many args to C-fn",op,NONCONTINUABLE);
  917.       else
  918.         {
  919. #ifdef BCI        
  920.           if (is_b_function(op)||is_b_macro(op))
  921.         {
  922.           return(apply_nary_bytefunction(stackbase,0,op));
  923.         }    
  924.           else
  925.         return(op->C_FUNCTION.func(stackbase));
  926. #else
  927.           return(op->C_FUNCTION.func(stackbase));
  928. #endif
  929.         }
  930.     }
  931.       for (i=0; i < args-1 ; i++)
  932.     {
  933.       STACK_TMP(nil); /* place where arg will go */
  934.       STACK_TMP(CDR(walker));
  935.       /* XXX assume 1) CDR(nil)=nil, module_eval(nil)=nil */
  936.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase)/*mod*/,
  937.                  ARG_1(stackbase)/* env */,CAR(walker)));
  938.       UNSTACK_TMP(walker);
  939.     }
  940.  
  941.       if (extra)
  942.     { 
  943.       LispObject ptr;
  944.  
  945.       if (walker!=nil)
  946.         {
  947.           LispObject xx;
  948.  
  949.           STACK_TMP(CDR(walker));
  950.           EUCALLSET_3(xx,module_eval,ARG_0(stackbase) /*mod*/,
  951.                               ARG_1(stackbase)/*env*/, CAR(walker));
  952.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  953.           UNSTACK_TMP(walker);
  954.           STACK_TMP(lastarg);
  955.           ptr = lastarg;
  956.           while(walker!=nil)
  957.         {    
  958.           STACK_TMP(CDR(walker));
  959.           STACK_TMP(ptr);
  960.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)    /*mod*/, 
  961.                   ARG_1(stackbase)/*env*/, CAR(walker));
  962.           xx = EUCALL_2(Fn_cons, xx, nil);
  963.           UNSTACK_TMP(ptr);
  964.           CDR(ptr)=xx;
  965.           ptr = CDR(ptr);
  966.           UNSTACK_TMP(walker);
  967.         }
  968.           UNSTACK_TMP(lastarg);
  969.         }
  970.       else
  971.         lastarg=nil;
  972.     }
  973.       else
  974.     {
  975.       if (walker == nil)
  976.         {
  977.           CallError(stacktop,
  978.             "C function wants more args", op, NONCONTINUABLE);
  979.         }
  980.  
  981.       if (CDR(walker)!=nil)
  982.         CallError(stacktop,"Eval: Too many args to 'C-function",CDR(walker),
  983.               NONCONTINUABLE);
  984.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase)/*mod*/,
  985.               ARG_1(stackbase)/*env*/,CAR(walker));
  986.     }
  987.       NARY_PUSH_ARG(lastarg);
  988.       op=ARG_3(stackbase);
  989.  
  990. #ifdef BCI
  991.       if (is_c_function(op)||is_c_macro(op))
  992.     return(NARY_EUCALL(op->C_FUNCTION.func));
  993.       else
  994.     {    /* B-function */
  995.       return(apply_nary_bytefunction(argbase,args,op));
  996.     }
  997. #else
  998.       return(NARY_EUCALL(op->C_FUNCTION.func));
  999. #endif
  1000.       END_NARY_EUCALL();
  1001.     }
  1002.  
  1003.   if (is_generic(op))
  1004.     { 
  1005.       RETURN_EUCALL(EUCALL_4(call_generic,mod,env,op,CDR(form)));
  1006.     }
  1007.  
  1008.  
  1009.   if (is_i_function(op)
  1010.       || is_i_macro(op))
  1011.     {
  1012.       LispObject args, exps, callenv;
  1013.       int extra;
  1014.  
  1015.       extra = ( op->I_FUNCTION.argtype < 0);
  1016.       callenv = (LispObject) op->I_FUNCTION.env;
  1017.       STACK_TMP(op);
  1018.       if (op->I_FUNCTION.argtype == 0)
  1019.     {
  1020.       if (CDR(form)!=nil)
  1021.         CallError(stackbase,"Too many args to I-function",op,NONCONTINUABLE);
  1022.     }
  1023.       else
  1024.     {    
  1025.       for ((args = op->I_FUNCTION.bvl,
  1026.         exps = CDR(form));
  1027.            is_cons(args);
  1028.            (args = CDR(args),
  1029.         exps = CDR(exps)))
  1030.         {
  1031.           if (exps == nil)
  1032.         {
  1033.           CallError(stacktop,
  1034.                 "i function wants more args", op, NONCONTINUABLE);
  1035.         }
  1036.           else
  1037.         {
  1038.           LispObject nextarg;
  1039.  
  1040.           STACK_TMP(exps);
  1041.           STACK_TMP(args);
  1042.           STACK_TMP(callenv);
  1043.           EUCALLSET_3(nextarg,module_eval,
  1044.                   ARG_0(stackbase) /*mod*/,
  1045.                   ARG_1(stackbase) /*env*/,
  1046.                   CAR(exps));
  1047.           UNSTACK_TMP(callenv);
  1048.           UNSTACK_TMP(args);
  1049.           STACK_TMP(args);
  1050.           callenv = allocate_env(stacktop,CAR(args),
  1051.                      nextarg, callenv);
  1052.           UNSTACK_TMP(args);
  1053.           UNSTACK_TMP(exps);
  1054.  
  1055.         }
  1056.           /* end i-function-loop */
  1057.         }
  1058.                           
  1059.       /* last arg */
  1060.  
  1061.       if (extra)
  1062.         {
  1063.           LispObject lastarg=nil;
  1064.  
  1065.           STACK_TMP(callenv); /* need this */
  1066.           STACK_TMP(args);
  1067.  
  1068.           if (exps!=nil)
  1069.         {
  1070.           LispObject xx;
  1071.           LispObject ptr;
  1072.  
  1073.           STACK_TMP(CDR(exps));
  1074.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1075.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1076.           EUCALLSET_2(lastarg,Fn_cons,xx,nil);
  1077.           UNSTACK_TMP(exps);
  1078.           STACK_TMP(lastarg);
  1079.           ptr = lastarg;
  1080.           while(exps!=nil)
  1081.             {    
  1082.               STACK_TMP(CDR(exps));
  1083.               STACK_TMP(ptr);
  1084.               EUCALLSET_3(xx, module_eval, ARG_0(stackbase) /*mod*/
  1085.                   , ARG_1(stackbase) /*env*/, CAR(exps));
  1086.               xx = EUCALL_2(Fn_cons, xx, nil);
  1087.               UNSTACK_TMP(ptr);
  1088.               CDR(ptr)=xx;
  1089.               ptr = CDR(ptr);
  1090.               UNSTACK_TMP(exps);
  1091.             }
  1092.           UNSTACK_TMP(lastarg);
  1093.         }
  1094.           else
  1095.         lastarg=nil;
  1096.  
  1097.           UNSTACK_TMP(args);
  1098.           UNSTACK_TMP(callenv);
  1099.           callenv = allocate_env(stacktop,args,lastarg, callenv);
  1100.         }
  1101.       else if (exps!=nil)
  1102.         {    
  1103.           UNSTACK_TMP(op);
  1104.           CallError(stackbase,"Too many args to i-function",op,NONCONTINUABLE);
  1105.         }
  1106.     }
  1107.  
  1108.       UNSTACK_TMP(op);
  1109.       /* now we call it.., cunningly inlining the progn */
  1110.  
  1111.       { LispObject forms = op->I_FUNCTION.body;
  1112.     /* Throw it all away */
  1113.     stacktop=stackbase;
  1114.     SET_TRACE(stackbase-3,op,callenv);
  1115.  
  1116.     while (CDR(forms)!=nil)
  1117.       {
  1118.         STACK_TMP(CDR(forms));
  1119.         STACK_TMP(callenv);
  1120.         STACK_TMP(op);
  1121.         EUCALL_3(module_eval,
  1122.              op->I_FUNCTION.home,
  1123.              callenv,
  1124.              CAR(forms));
  1125.         UNSTACK_TMP(op);
  1126.         UNSTACK_TMP(callenv);
  1127.         UNSTACK_TMP(forms);
  1128.       }
  1129.  
  1130.     mod = ARG_0(stackbase) = op->I_FUNCTION.home;
  1131.     env = ARG_1(stackbase) = callenv;
  1132.     form = ARG_2(stackbase) = CAR(forms);
  1133.     goto toplabel;
  1134.       }
  1135.     }
  1136.   
  1137.   if (is_special(op))
  1138.     {
  1139.       if (op==special_progn)
  1140.     { LispObject forms = CDR(form);
  1141.     
  1142.       while (CDR(forms)!=nil)
  1143.         {
  1144.           STACK_TMP(CDR(forms));
  1145.           EUCALL_3(module_eval,
  1146.                ARG_0(stackbase)/*mod*/,
  1147.                ARG_1(stackbase)/*env*/,
  1148.                CAR(forms));
  1149.           UNSTACK_TMP(forms);
  1150.         }
  1151.  
  1152.       EUTAIL_3(ARG_0(stackbase)/*mod*/,
  1153.            ARG_1(stackbase)/*env*/,
  1154.            CAR(forms));
  1155.     }
  1156.       if (op == special_if)
  1157.     {    
  1158.       LispObject res,stmt=CDR(form);
  1159.       check_if(stmt);
  1160.       
  1161.       STACK_TMP(CDR(stmt));
  1162.       res = EUCALL_3(module_eval,mod,env,CAR(stmt));
  1163.       if ( res == nil)
  1164.         {
  1165.           UNSTACK_TMP(stmt);
  1166.           EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/
  1167.                ,CAR(CDR(stmt)));
  1168.         }
  1169.       UNSTACK_TMP(stmt);
  1170.       EUTAIL_3(ARG_0(stackbase)/*mod*/,ARG_1(stackbase)/*env*/,CAR(stmt));
  1171.     }
  1172.  
  1173.       if (op->SPECIAL.env==NULL)
  1174.     RETURN_EUCALL(EUCALL_3(op->SPECIAL.func,mod,env,CDR(form)));
  1175.       else
  1176.     RETURN_EUCALL(EUCALL_2(op->SPECIAL.func,mod,CDR(form)));
  1177.     }
  1178.  
  1179.   if (is_continue(op))
  1180.     { LispObject res;
  1181.       
  1182.       res = EUCALL_3(module_eval,mod,env,CAR(CDR(form)));
  1183.       op=ARG_3(stackbase);
  1184.       call_continuation(stacktop,op,res);
  1185.       return nil; /* not really */
  1186.     }
  1187.  
  1188.  
  1189.  
  1190.   fprintf(stderr,"{?: 0x%x}",op);
  1191.   CallError(stacktop, "Unknown operator thing",op,NONCONTINUABLE);
  1192.   return nil; /* not ever */
  1193. }
  1194.  
  1195.  
  1196.  
  1197. /* The same, but different... we could be clever + do the tail call properly*/
  1198. EUFUN_4( call_generic, mod, env, gf, forms)
  1199. {
  1200.   LispObject lastarg;
  1201.   LispObject walker, extras = nil;
  1202.   int i, args, extra;
  1203.   BEGIN_NARY_EUCALL();
  1204.  
  1205.   walker = forms;
  1206.   args = intval(generic_argtype(gf));
  1207.   extra = (args < 0);
  1208.   args = extra ? -args : args;
  1209.  
  1210.   /* Too much cut and paste! */
  1211.   for (i=0; i < args-1 ; i++)
  1212.     {
  1213.       STACK_TMP(nil);        /* place where arg will go */
  1214.       STACK_TMP(CDR(walker));
  1215.       NARY_PUSH_ARG(EUCALL_3(module_eval,ARG_0(stackbase) /*mod*/,
  1216.                  ARG_1(stackbase) /* env */,CAR(walker)));
  1217.       UNSTACK_TMP(walker);
  1218.  
  1219.       if (walker == nil)
  1220.     {
  1221.       CallError(stacktop,
  1222.             "Generic function wants more args", gf, NONCONTINUABLE);
  1223.     }
  1224.     }
  1225.  
  1226.   if (extra)
  1227.     { 
  1228.       LispObject ptr;
  1229.  
  1230.       stacktop=argbase+argcount;
  1231.  
  1232.       if (walker!=nil)
  1233.     {
  1234.       STACK_TMP(CDR(walker));
  1235.       EUCALLSET_2(lastarg,Fn_cons,CAR(walker),nil);
  1236.       UNSTACK_TMP(walker);
  1237.       STACK_TMP(lastarg);
  1238.       ptr = lastarg;
  1239.       while(walker!=nil)
  1240.         {    
  1241.           LispObject xx;
  1242.           STACK_TMP(CDR(walker));
  1243.           STACK_TMP(ptr);
  1244.           EUCALLSET_3(xx, module_eval, ARG_0(stackbase)/*mod*/, ARG_1(stackbase)/*env*/, CAR(walker));
  1245.           xx = EUCALL_2(Fn_cons, xx, nil);
  1246.           UNSTACK_TMP(ptr);
  1247.           CDR(ptr)=xx;
  1248.           ptr = CDR(ptr);
  1249.           UNSTACK_TMP(walker);
  1250.         }
  1251.       UNSTACK_TMP(lastarg);
  1252.     }
  1253.       else
  1254.     lastarg=nil;
  1255.     }
  1256.   else
  1257.     {     
  1258.       if (CDR(walker)!=nil)
  1259.     CallError(stacktop,"Eval: Too many args to Generic-function",CDR(walker),
  1260.           NONCONTINUABLE);
  1261.       EUCALLSET_3(lastarg,module_eval,ARG_0(stackbase) /*mod*/,ARG_1(stackbase)/*env*/,CAR(walker));
  1262.     }
  1263.   NARY_PUSH_ARG(lastarg);
  1264.   gf=ARG_2(stackbase);
  1265.   return(NARY_EUCALL_1(generic_apply,gf));
  1266.   END_NARY_EUCALL();
  1267. }
  1268. EUFUN_CLOSE
  1269.  
  1270. EUFUN_2(module_mv_apply_1,op, form)
  1271. {
  1272.   LispObject module_apply_args(LispObject *, int , LispObject );
  1273.   LispObject *walker=stackbase;
  1274.   int n=0;
  1275.  
  1276.   while (is_cons(form))
  1277.     {
  1278.       *walker=CAR(form);
  1279.       form=CDR(form);
  1280.       walker++;
  1281.       n++;
  1282.     }
  1283.  
  1284.   if (form!=nil)
  1285.     CallError(stackbase,"Improper list passed to mv_apply",nil,NONCONTINUABLE);
  1286.  
  1287.   return(module_apply_args(stackbase,n,op));
  1288.   
  1289. }
  1290. EUFUN_CLOSE
  1291.  
  1292. /* More restatement */
  1293. LispObject module_apply_args(LispObject *stackbase, int callargs, LispObject fn)
  1294. {
  1295.   void listify_args(LispObject *,int ,LispObject *);
  1296.   LispObject *stacktop=stackbase+callargs;
  1297.  
  1298.   if (is_i_function(fn) || is_i_macro(fn))
  1299.     {
  1300.       int nargs=fn->I_FUNCTION.argtype;
  1301.       LispObject env=(LispObject)fn->I_FUNCTION.env;
  1302.       LispObject args;
  1303.       LispObject *walker=stackbase;
  1304.       int extras;
  1305.       
  1306.       extras= (nargs<0);
  1307.       
  1308.       if (nargs==0 && callargs==0)
  1309.     RETURN_EUCALL(EUCALL_3(Sf_progn,
  1310.                    fn->I_FUNCTION.home,
  1311.                    env,
  1312.                    fn->I_FUNCTION.body));
  1313.  
  1314.       if ( (callargs!=nargs)
  1315.       && (!extras || (extras && callargs < -nargs-1)))
  1316.     CallError(stackbase,"apply: i-function called with wrong number of args",fn,NONCONTINUABLE);
  1317.       
  1318.       STACK_TMP(fn);    /* we stack it twice on the off chance */
  1319.       STACK_TMP(fn);    /* it is an nary function called with n-1 args */
  1320.       for (args=fn->I_FUNCTION.bvl;
  1321.        is_cons(args);
  1322.        )
  1323.     {
  1324.       STACK_TMP(CDR(args));
  1325.       env=allocate_env(stacktop,CAR(args),*walker,env);
  1326.       walker++;
  1327.       UNSTACK_TMP(args);
  1328.     }
  1329.       if (args!=nil)
  1330.     {
  1331.       STACK_TMP(env); STACK_TMP(args);
  1332.       if (callargs!=nargs)
  1333.         listify_args(walker,callargs+nargs+1,stacktop);
  1334.  
  1335.       UNSTACK_TMP(args); UNSTACK_TMP(env);
  1336.       env=allocate_env(stacktop,args,*walker,env);
  1337.     }
  1338.       UNSTACK_TMP(fn);
  1339. #if 0 /* Stack paranioa */
  1340.       if (!is_i_function(fn) && !is_i_macro(fn))
  1341.     system_lisp_exit(0);
  1342. #endif
  1343.       RETURN_EUCALL(EUCALL_3(Sf_progn,
  1344.                  fn->I_FUNCTION.home,
  1345.                  env,
  1346.                  fn->I_FUNCTION.body));
  1347.       
  1348.     }    
  1349.   
  1350.   if (is_c_function(fn) || is_c_macro(fn) 
  1351. #ifdef BCI      
  1352.       || is_b_function(fn) || is_b_macro(fn)
  1353. #endif
  1354.       )
  1355.     {
  1356. #ifdef BCI
  1357.       int nargs=
  1358.     ((is_c_function(fn)||is_c_macro(fn))
  1359.      ? fn->C_FUNCTION.argtype
  1360.      : intval(bytefunction_nargs(fn)));
  1361. #else
  1362.       int nargs = fn->C_FUNCTION.argtype;
  1363. #endif
  1364.       if (is_c_function(fn) && fn->C_FUNCTION.env!=NULL)
  1365.     {    /* Whups --- the env needs to be inserted */
  1366.       int i;
  1367.       
  1368.       for (i=callargs; i>=0; i--)
  1369.         stackbase[i+1]=stackbase[i];
  1370.  
  1371.       stackbase[0]=(LispObject)fn->C_FUNCTION.env;
  1372.     }
  1373.       if (callargs!=nargs)
  1374.     {
  1375.       if (nargs<0 && callargs>= -nargs-1)
  1376.         {    
  1377.           int act= -nargs-1;
  1378.  
  1379.           STACK_TMP(fn); /* could be anything --- just to stop the */
  1380.           STACK_TMP(fn); /* value being blatted */
  1381.           listify_args(stackbase+act,callargs-act,stacktop);
  1382.           UNSTACK_TMP(fn);
  1383.         }
  1384.       else
  1385.         CallError(stacktop,"C function called with wrong number of args",fn,NONCONTINUABLE);
  1386.     }
  1387. #ifdef BCI
  1388.       if (is_c_function(fn) || is_c_macro(fn))
  1389.     return((fn->C_FUNCTION.func)(stackbase));
  1390.       else
  1391.     return(apply_nary_bytefunction(stackbase,
  1392.                        nargs>0 ? nargs : -nargs,
  1393.                        fn));
  1394. #else
  1395.       return((fn->C_FUNCTION.func)(stackbase));
  1396. #endif      
  1397.     }            
  1398.  
  1399.   if (is_generic(fn))
  1400.     {    
  1401.       int nargs=intval(generic_argtype(fn));
  1402.       
  1403.       if (nargs!=callargs)
  1404.     CallError(stacktop,"Generic called with wrong number of args",fn,NONCONTINUABLE);
  1405.  
  1406.       return(generic_apply(stackbase,fn));
  1407.     }
  1408.  
  1409.   if (is_continue(fn))
  1410.     {
  1411.       if (callargs==0)
  1412.     {
  1413.       call_continuation(stackbase,fn,nil);
  1414.       return nil; 
  1415.     }
  1416.  
  1417.       if (callargs==1)
  1418.     {
  1419.       call_continuation(stackbase,fn,*stackbase);
  1420.     }
  1421.       CallError(stackbase,"apply: continuation: too many args",fn,NONCONTINUABLE);
  1422.       /* nope */
  1423.       return nil;
  1424.     }
  1425.  
  1426.   
  1427.   CallError(stacktop, "module multiple-apply: invalid op",fn,
  1428.         NONCONTINUABLE);
  1429.   return nil;
  1430. }
  1431.  
  1432. /* Should be a macro */
  1433. void listify_args(LispObject *start,int n,LispObject *stacktop)
  1434. {
  1435.   int i;
  1436.   LispObject lst;
  1437.  
  1438.   if (n==0)
  1439.     {
  1440.       *start=nil;
  1441.       return;
  1442.     }
  1443.   
  1444.   lst=allocate_n_conses(stacktop,n);
  1445.   CAR(lst)= *start;
  1446.   *start = lst;
  1447.  
  1448.   start++;
  1449.   lst=CDR(lst);
  1450.   for (i=1; i<n; i++)
  1451.     {
  1452.       CAR(lst) = *start;
  1453.       lst=CDR(lst);
  1454.       start++;
  1455.     }
  1456. }
  1457. #define SYM_REF_DBG(x) /* x;fflush(stderr); */
  1458.  
  1459. LispObject symbol_ref(LispObject *stacktop,
  1460.               LispObject mod,LispObject env,LispObject sym)
  1461. {
  1462.   Env walker;
  1463.   LispObject spec;
  1464.  
  1465. SYM_REF_DBG(fprintf(stderr,"symol_ref with sym '%s'\n",stringof(sym->symbol.pname)));
  1466.  
  1467.   /* parameter environment */
  1468.  
  1469.   walker = &(env->ENV);
  1470.  
  1471. SYM_REF_DBG(fprintf(stderr,"symol_ref env search\n"));
  1472.  
  1473.   while (walker != NULL) {
  1474.     if (walker->variable == sym) 
  1475.       return(walker->value);
  1476.     else
  1477.       walker = walker->next;
  1478.   }
  1479.  
  1480.   /* self evaluating symbols */
  1481.  
  1482.   if (sym == sym_nil) return(nil);
  1483.   if (sym == lisptrue) return(lisptrue);
  1484.   
  1485.   /* Check caches */
  1486.   if (sym->SYMBOL.lmodule == mod) return(sym->SYMBOL.lvalue);
  1487.  
  1488.   /* language constructs and key words */
  1489.  
  1490.   spec=EUCALL_2(Fn_tref,special_table,sym);
  1491.  
  1492.   if (spec != nil) 
  1493.     {
  1494.       sym->SYMBOL.lmodule=mod;
  1495.       sym->SYMBOL.lvalue=spec;
  1496.       return spec;    
  1497.     }
  1498.   
  1499.   /* module reference */
  1500.  
  1501.   return(EUCALL_2(Fn_module_value,mod,sym));
  1502. }
  1503.  
  1504.  
  1505. LispObject module_set_new(LispObject *stacktop,LispObject mod,LispObject sym,LispObject val)
  1506. {
  1507.   return(EUCALL_4(module_set_new_aux,mod,sym,val,lisptrue));
  1508. }
  1509.  
  1510. LispObject module_set_new_constant(LispObject *stacktop,LispObject mod,
  1511.                    LispObject sym,LispObject val)
  1512. {
  1513.   return(EUCALL_4(module_set_new_aux,mod,sym,val,nil));
  1514. }
  1515.  
  1516.  
  1517. EUFUN_2(Fn_module_value, mod, sym)
  1518. {
  1519.   LispObject bind;
  1520.   
  1521.   bind=GET_BINDING(mod,sym);
  1522.  
  1523.   if (bind==nil)
  1524.     {
  1525.       LispObject xx;
  1526.       xx=EUCALL_2(Fn_cons,mod->MODULE.name,sym);
  1527.       CallError(stacktop,"module value: No such binding",xx,NONCONTINUABLE);
  1528.     }
  1529.   if (is_cons(bind))
  1530.     { /* Good value */
  1531.       LispObject val;
  1532.  
  1533.       if (is_i_module(BINDING_HOME(bind)))
  1534.     {
  1535.       val = BINDING_VALUE(bind);
  1536.       sym->SYMBOL.lmodule=mod;
  1537.       sym->SYMBOL.lvalue=val;
  1538.       return val;
  1539.     }
  1540.       if (is_c_module(BINDING_HOME(bind)))
  1541.     {
  1542.       val=vref((BINDING_HOME(bind)->C_MODULE.values),intval(BINDING_VALUE(bind)));
  1543.       sym->SYMBOL.lmodule=mod;
  1544.       sym->SYMBOL.lvalue=val;
  1545.       return val;
  1546.     }
  1547.       else 
  1548.     CallError(stacktop,"Unexpected module type",bind,NONCONTINUABLE);    
  1549.     }
  1550.  
  1551.   CallError(stacktop,"Unexpected value of binding",bind,NONCONTINUABLE);
  1552.   return nil;
  1553. }
  1554. EUFUN_CLOSE
  1555.  
  1556. EUFUN_3(module_set,mod, sym, val)
  1557. {
  1558.   LispObject bind;
  1559.  
  1560.   
  1561.   if (is_c_module(mod))
  1562.     CallError(stacktop,"module set: can't set in compiled module",sym,NONCONTINUABLE);
  1563.  
  1564.   if(reserved_symbol_p(sym))
  1565.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1566.  
  1567.   bind=GET_BINDING(mod,sym);
  1568.  
  1569.   if (bind==nil)
  1570.     {    /* Be kind and add it anyhow */
  1571.       sym->SYMBOL.lmodule=nil;
  1572.       sym->SYMBOL.lvalue=nil;
  1573.       ADD_BINDING(ARG_0(stackbase)/* mod*/, ARG_1(stackbase)/*sym*/,
  1574.           ARG_2(stackbase)/*val*/,lisptrue);
  1575.       return ARG_2(stackbase);
  1576.     }
  1577.   
  1578.   if (BINDING_MUTABLE(bind)==lisptrue)
  1579.     {
  1580.       sym->SYMBOL.lmodule=nil;
  1581.       sym->SYMBOL.lvalue=nil;
  1582.       BINDING_VALUE(bind)=val;
  1583.       return val;
  1584.     }
  1585.   else
  1586.     {
  1587.       sym->SYMBOL.lmodule=nil;
  1588.       sym->SYMBOL.lvalue=nil;
  1589.       
  1590.       fprintf(StdErr->STREAM.handle,"*** Setting immutable binding\n");
  1591.       BINDING_VALUE(bind)=val;
  1592.       return val;
  1593.     }
  1594.   
  1595.   CallError(stacktop,"module set: How the hell did I get here",sym,NONCONTINUABLE);
  1596.   return nil;
  1597. }
  1598. EUFUN_CLOSE
  1599.  
  1600. static EUFUN_4(module_set_new_aux,mod,sym,val,mutability)
  1601. {
  1602.   LispObject bind;
  1603.  
  1604.   if (!is_i_module(mod))
  1605.     CallError(stacktop,"Module set new: tried to set in compiled module",sym,NONCONTINUABLE);
  1606.  
  1607.   if(reserved_symbol_p(sym))
  1608.     CallError(stacktop,"module set: can't set reserved symbol",sym,NONCONTINUABLE);
  1609.  
  1610.   bind=GET_BINDING(mod,sym);
  1611.   
  1612.   if (bind==nil)
  1613.     { /* Its a newie */
  1614.       ADD_BINDING(ARG_0(stackbase),ARG_1(stackbase),ARG_2(stackbase),ARG_3(stackbase));
  1615.       sym->SYMBOL.lmodule=nil;
  1616.       sym->SYMBOL.lvalue=nil;
  1617.       return ARG_1(stackbase);
  1618.     }
  1619.   else
  1620.     {
  1621.       if (BINDING_HOME(bind)==mod)
  1622.     {
  1623.       sym->SYMBOL.lmodule=nil;
  1624.       sym->SYMBOL.lvalue=nil;
  1625.       BINDING_VALUE(bind)=val;
  1626.       BINDING_MUTABLE(bind)=mutability;
  1627.       return sym;
  1628.     }
  1629.       else
  1630.     CallError(stacktop,"Module set new: tried to set over imported binding",sym,NONCONTINUABLE);
  1631.     }
  1632.   /* NOT ever */
  1633.   return nil; 
  1634. }
  1635. EUFUN_CLOSE
  1636.  
  1637. EUFUN_4(register_module_import, mod, name, inmod, inname)
  1638. {
  1639.   LispObject bind, localbind;
  1640.   LispObject xx;
  1641.   if (is_c_module(mod))
  1642.     CallError(stacktop, "register import: can't import into compiled module",
  1643.           mod,NONCONTINUABLE);
  1644.  
  1645.   /* ok, but is it exported anyhow ? */
  1646.  
  1647.   EUCALLSET_2(xx, Fn_memq, inname, module_exports(inmod));
  1648.   if (xx == nil)
  1649.     CallError(stacktop, "register import: name not exported",inname,
  1650.           NONCONTINUABLE);
  1651.   
  1652.   /* Into canonical form */
  1653.  
  1654.   bind=GET_BINDING(inmod,inname);
  1655.   
  1656.   if (bind==nil)
  1657.     {
  1658.       xx=EUCALL_2(Fn_cons,inmod->C_MODULE.name,inname);
  1659.       CallError(stacktop,"non-existent binding exported", xx,NONCONTINUABLE);
  1660.     }
  1661.   /* See if we have something of the same name */
  1662.   localbind=GET_BINDING(mod,name);
  1663.  
  1664.   if (localbind==nil)
  1665.     { /* add it */
  1666.       IMPORT_BINDING(mod,name,bind);
  1667.       return nil;
  1668.     }
  1669.   else 
  1670.     {
  1671.       if (bind==localbind) /* done this before */
  1672.     return nil;
  1673.       else 
  1674.     {
  1675.       xx=EUCALL_2(Fn_cons, inmod->C_MODULE.name,name);
  1676.       CallError(stacktop,"register import: binding exists locally",xx,NONCONTINUABLE);
  1677.     }
  1678.     }
  1679.  
  1680.   CallError(stacktop,"Register import: Yeouch. not here",nil,NONCONTINUABLE);
  1681.  
  1682.   return nil;
  1683. }
  1684. EUFUN_CLOSE
  1685.  
  1686. int module_binding_exists_p(LispObject *stacktop,LispObject mod,LispObject name)
  1687. {
  1688.   LispObject bind;
  1689.   
  1690.   bind=GET_BINDING(mod,name);
  1691.   
  1692.   return (bind!=nil);
  1693. }    
  1694.  
  1695.  
  1696. /* *************************************************************** */
  1697. /* Initialisation of this section                                  */
  1698. /* *************************************************************** */
  1699.  
  1700. void initialise_modules(LispObject *stacktop)
  1701. {
  1702.   extern MODULE *current_open_module;
  1703.  
  1704.   sym_include_forms = get_symbol(stacktop,"include-forms");
  1705.   add_root(&sym_include_forms);
  1706.   SYSTEM_INITIALISE_GLOBAL(LispObject,current_interactive_module,NULL);
  1707.   ADD_SYSTEM_GLOBAL_ROOT(current_interactive_module);
  1708.   global_module_table = (LispObject) allocate_table(stacktop,Fn_eq);
  1709.   add_root(&global_module_table);
  1710.   add_root((LispObject*)¤t_open_module);
  1711.   backtrace_handle = get_symbol(stacktop,"****backtrace-handle****");
  1712.   add_root(&backtrace_handle);
  1713.   sym_only   = get_symbol(stacktop,"only");
  1714.   add_root(&sym_only);
  1715.   sym_except = get_symbol(stacktop,"except");
  1716.   add_root(&sym_except);
  1717. }
  1718.  
  1719.